home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 6
/
Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso
/
025a
/
gsdb25.zip
/
GS_DBFLD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-08-01
|
48KB
|
1,421 lines
{ dBase III Field Handler
GS_DBFLD Copyright (c) Richard F. Griffin
15 November 1990
102 Molded Stone Pl
Warner Robins, GA 31088
-------------------------------------------------------------
This unit handles field processing for all dBase III file (.DBF)
operations.
SHAREWARE -- COMMERCIAL USE RESTRICTED
Changes:
02 May 91 - Changed the type of value returned for a date field from
string to longint. The value assigned is the julian date.
Note that the Julian day number is not the same as the
serial day number (1-366) which is sometimes (erroneously)
called a Julian date. Refer to the GS_Date unit for more
information.
03 May 91 - Ensured Date field is a julian date for .NDX indexes in the
IndexTo method.
02 Jun 91 - Allowed a 'blank' date field to be acccepted if the field
was originally blank in AcceptField.
31 Jul 91 - Created a StatusUpdate virtual method to allow a user to
track progress of actions such as Pack and IndexTo. The
status will be passed to StatusUpdate from within those
methods. The basic StatusUpdate is empty and does nothing
with the passed status. The user has the option to create
his own virtual method to capture this information.
}
{
┌──────────────────────┐
│ INTERFACE SECTION: │
└──────────────────────┘
}
unit GS_dBFld;
interface
uses
CRT,
GS_Date,
GS_Edit,
GS_FileH,
GS_Error,
GS_KeyI,
GS_Strng,
GS_Winfc,
GS_dBase;
const
StatusStart = -1;
StatusStop = 0;
StatusIndexTo = 1;
StatusPack = 2;
type
GS_dBFld_Objt = object(GS_dBase_dB)
LastFldTyp : char; {Last FieldGet type field}
LastFldDec : integer; {Last FieldGet Decimals}
LastFldLth : integer; {Last FieldGet Length}
LastFldNam : string[11]; {Last FieldGet Name}
LastFldNum : integer; {Last FieldGet Number}
EditOn : boolean; {Edit allowed}
RecChanged : boolean; {Flag for record changed}
Memo_Loc : longint; {Starting memo block for field}
Memo_Bloks : integer; {Number of blocks used for the field}
Memo_Store : GS_Edit_Objt; {Object to store/edit memos}
DeleteOnF9 : boolean; {Flag to permit F9 to delete/undelete}
Procedure Check_Func_Keys; virtual;
Function Create(FName : string) : boolean;
function DateGet(st : string) : longint;
function DateGetN(n : integer) : longint;
Procedure DatePut(st : string; jdte : longint);
Procedure DatePutN(n : integer; jdte : longint);
Function FieldAccept(st,Titl : string; x,y : integer) : string;
Procedure FieldDisplay(st,Titl : string; x,y : integer);
Function FieldDisplayScreen : boolean;
Function FieldGet(st : string) : string;
Function FieldGetN(n : integer) : string;
Procedure FieldPut(st1, st2 : string);
Procedure FieldPutN(n : integer; st1 : string);
Function FieldUpdateScreen : boolean;
Function FieldAppendScreen(empty : boolean) : boolean;
Function Formula(st : string; var ftyp : char) : string; virtual;
Function HuntFieldName(st : string; var fs : integer) : boolean;
Procedure IndexTo(filname, formla : string);
Constructor Init(FName : string);
function LogicGet(st : string) : boolean;
function LogicGetN(n : integer) : boolean;
Procedure LogicPut(st : string; b : boolean);
Procedure LogicPutN(n : integer; b : boolean);
Procedure MemoEdit;
function MemoGetLine(linenum : integer) : string;
procedure MemoGet(rpt : string);
Procedure MemoWidth(l : integer);
function MemoLines : integer;
function MemoPut : string;
function NumberGet(st : string) : real;
function NumberGetN(n : integer) : real;
Procedure NumberPut(st : string; r : real);
Procedure NumberPutN(n : integer; r : real);
Procedure Pack;
Procedure StatusUpdate(statword1,statword2,statword3 : longint); virtual;
function StringGet(st : string) : string;
function StringGetN(n : integer) : string;
Procedure StringPut(st1, st2 : string);
Procedure StringPutN(n : integer; st1 : string);
end;
implementation
procedure GS_dBFld_Objt.Check_Func_Keys;
begin
case ch of
Kbd_F9 : begin
if DeleteOnF9 then
begin
if RecNumber < 0 then
begin
if DelFlag then CurRecord^[0] := 32
else CurRecord^[0] := 42;
DelFlag := not DelFlag;
end
else if DelFlag then UnDelete else Delete;
GS_KeyI_Ret := true;
Ch := Kbd_Ret;
end else GS_dBase_DB.Check_Func_Keys;
end;
Kbd_F10 : begin
GS_KeyI_Ret := true;
Ch := Kbd_Ret;
end;
else GS_dBase_DB.Check_Func_Keys;
end;
end;
function GS_dBFld_Objt.DateGet(st : string) : longint;
var
t : string;
v : longint;
begin
t := FieldGet(st);
v := GS_Date_Juln(t);
if v > 0 then DateGet := v else DateGet := 0;
end;
function GS_dBFld_Objt.DateGetN(n : integer) : longint;
var
t : string;
v : longint;
begin
t := FieldGetN(n);
v := GS_Date_Juln(t);
if v > 0 then DateGetN := v else DateGetN := 0;
end;
Procedure GS_dBFld_Objt.DatePut(st : string; jdte : longint);
var
f : integer;
t : string[8];
begin
if not HuntFieldName(st,f) then
begin
ShowError(625,st);
exit;
end;
if jdte = 0 then t := ' '
else t := GS_Date_DBStor(jdte);
FieldPutN(f,t);
end;
Procedure GS_dBFld_Objt.DatePutN(n : integer; jdte : longint);
var
t : string[8];
begin
if n > NumFields then
begin
ShowError(627,'Field number out of range');
exit;
end;
if jdte = 0 then t := ' '
else t := GS_Date_DBStor(jdte);
FieldPutN(n,t);
end;
function GS_dBFld_Objt.LogicGet(st : string) : boolean;
begin
LogicGet := ValLogic(FieldGet(st));
end;
function GS_dBFld_Objt.LogicGetN(n : integer) : boolean;
begin
LogicGetN := ValLogic(FieldGetN(n));
end;
Procedure GS_dBFld_Objt.LogicPut(st : string; b : boolean);
begin
FieldPut(st,StrLogic(b));
end;
Procedure GS_dBFld_Objt.LogicPutN(n : integer; b : boolean);
begin
FieldPutN(n,StrLogic(b));
end;
function GS_dBFld_Objt.NumberGet(st : string) : real;
var
r : integer;
v : real;
s : string;
begin
s := TrimR(FieldGet(st));
r := 0;
if s = '' then v := 0 else val(s,v,r);
if r <> 0 then
begin
ShowError(620,'Not a valid numeric field in NumberGet'+s);
v := 0;
end;
NumberGet := v;
end;
function GS_dBFld_Objt.NumberGetN(n : integer) : real;
var
r : integer;
v : real;
s : string;
begin
s := TrimR(FieldGetN(n));
r := 0;
if s = '' then v := 0 else val(s,v,r);
if r <> 0 then
begin
ShowError(620,'Not a valid numeric field in NumberGetN - '+s);
v := 0;
end;
NumberGetN := v;
end;
Procedure GS_dBFld_Objt.NumberPut(st : string; r : real);
var
f : integer;
s : string;
begin
if not HuntFieldName(st,f) then
begin
ShowError(625,st);
exit;
end;
Str(r:LastFldLth:LastFldDec,s);
FieldPutN(f,s);
end;
Procedure GS_dBFld_Objt.NumberPutN(n : integer; r : real);
var
s : string;
begin
if n > NumFields then
begin
ShowError(627,'Field number out of range');
exit;
end;
Str(r:Fields^[n].FieldLen:Fields^[n].FieldDec,s);
FieldPutN(n,s);
end;
function GS_dBFld_Objt.StringGet(st : string) : string;
begin
StringGet := TrimR(FieldGet(st));
end;
function GS_dBFld_Objt.StringGetN(n : integer) : string;
begin
StringGetN := TrimR(FieldGetN(n));
end;
Procedure GS_dBFld_Objt.StringPut(st1,st2 : string);
begin
FieldPut(st1,st2);
end;
Procedure GS_dBFld_Objt.StringPutN(n : integer; st1 : string);
begin
FieldPutN(n,st1);
end;
function GS_dBFld_Objt.HuntFieldName(st : string; var fs : integer) : boolean;
var
FSt : string;
mtch : boolean;
begin
FSt := AllCaps(st); {Capitalize the workstring}
FSt := TrimR(FSt); {Remove trailing spaces}
fs := 1; {Initialize field count}
mtch := false; {Set match found to false}
while (not mtch) and (fs <= NumFields) DO
if FieldsN^[fs] = FSt then mtch := true else inc(fs);
if mtch then
begin
LastFldTyp := Fields^[fs].FieldType;
LastFldDec := Fields^[fs].FieldDec;
LastFldLth := Fields^[fs].FieldLen;
end;
HuntFieldName := mtch;
end;
Function GS_dBFld_Objt.Create(FName : string) : boolean;
begin
if GS_dBase_DB.Create(FName) then
begin
Init(FName);
Create := true;
end else Create := false;
end;
Procedure GS_dBFld_Objt.Pack;
const
EOFMark : Byte = $1A;
var
df : file; {Local file variable for memo work file}
mbuf : array[0..GS_dBase_MaxMemoRec] of byte;
rsl : word;
i, j : longint; {Local variables }
mcnt,
tcnt : longint;
done : boolean;
rl : real;
FNam : string[64];
procedure UpdateMemo;
var
fp : integer;
begin
for fp := 1 to NumFields do
begin
if Fields^[fp].FieldType = 'M' then
begin
Memo_Loc := Trunc(NumberGetN(fp));
Memo_Bloks := 0; {Initialize blocks read}
if (Memo_Loc <> 0) then
begin
tcnt := GS_FileSize(df);
rl := tcnt;
NumberPutN(fp,rl);
done := false; {Reset done flag to false}
while (not done) do {loop until done (EOF mark)}
begin
GS_FileRead(mFile, Memo_Loc+Memo_Bloks, mbuf, 1, rsl);
inc(Memo_Bloks);
mCnt := 0; {Counter into disk read buffer}
while (mCnt < GS_dBase_MaxMemoRec) and (done = false) do
begin
if mbuf[mcnt] = $1A then done := true;
inc (mcnt);
end;
if not done then GS_FileWrite(df,-1,mbuf,1, rsl);
end;
FillChar(mbuf[mcnt],GS_dBase_MaxMemoRec - mcnt,#0);
GS_FileWrite(df,-1,mbuf,1, rsl);
{Write the last block to the .DBT}
end;
end;
end;
end;
begin {Pack}
StatusUpdate(StatusStart,StatusPack,NumRecs);
i := 1;
while dbfNdxTbl[i] <> nil do
begin
dbfNdxTbl[i]^.Ndx_Close;
Dispose(dbfNdxTbl[i]);
dbfNdxTbl[i] := nil;
inc(i);
end;
dbfNdxActv := false; {Set index active flag to false}
j := 0;
if WithMemo then
begin
GS_FileAssign(df,'DB3$$$.D$$',2048);
GS_FileRewrite(df,GS_dBase_MaxMemoRec);
FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
mbuf[0] := 1;
GS_FileWrite(df,0,mbuf,1,rsl);
end;
for i := 1 to NumRecs do {Read .DBF sequentially}
begin
GetRec(i);
if not DelFlag then {Write to work file if not deleted}
begin
inc(j); {Increment record count for packed file }
if WithMemo then UpdateMemo;
PutRec(j);
end;
StatusUpdate(StatusPack,i,0);
end;
if i > j then {If records were deleted then...}
begin
NumRecs := j; {Store new record count in objectname}
GS_FileWrite(dfile, HeadLen+(j*RecLen)+1, EOFMark, 1, rsl);
{Write End of File byte at file end}
GS_FileTruncate(dfile,HeadLen+(j*RecLen)+1);
{Set new file size for dBase file};
end;
if WithMemo then
begin
tcnt := GS_FileSize(df);
FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
Move(tcnt,mbuf[0],4);
GS_FileWrite(df,0,mbuf,1, rsl);
{Write the block to the .DBT. It will}
{point to the next available block};
FNam := FileName;
FNam[length(FNam)] := 'T';
GS_FileClose(mFile);
GS_FileClose(df);
GS_FileErase(mFile); {Erase original file}
GS_FileRename(df, FNam); {Rename work file to original file name}
GS_FileAssign(mFile, FNam, 2048); {Set file type to new file}
GS_FileReset(mFile, GS_dBase_MaxMemoRec);
end;
StatusUpdate(StatusStop,0,0);
END; { Pack }
Function GS_dBFld_Objt.FieldAccept(st,Titl : string; x,y : integer) : string;
var
txtatrb,
i,
v : integer; {Counter variables}
t : string[255]; {Work string to hold default (old) value}
f : string[2];
Procedure AcceptC;
var
r_c : string;
begin
GS_Wind_SetIVMode;
if EditOn then {If edit permitted, then go edit string}
begin
r_c := t;
t := EditString(t, v, y, LastFldLth);
if t <> r_c then RecChanged := true;
end
else
begin
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Rewrite the string on screen inverted}
WaitForKey;
end;
GS_Wind_SetNmMode;
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Rewrite the string on screen in the original color}
end;
Procedure AcceptD;
var
okDate : boolean;
v1,
v2 : longint;
h1 : string[10];
begin
t := TrimR(t);
if length(t) <> 8 then
begin
t := ' / / ';
if not GS_Date_Century then t[0] := #8;
end
else
begin
v1 := GS_Date_Juln(t);
t := GS_Date_View(v1);
end;
h1 := t;
LastFldLth := length(t);
okDate := false;
repeat
AcceptC;
if EditOn then
begin
if GS_KeyI_Esc then v2 := v1
else v2 := GS_Date_Juln(t);
if v2 >= 0 then
begin
okDate := true;
t := GS_Date_DBStor(v2);
end
else
begin
if t = h1 then
begin
t := FieldGet(st);
okDate := true;
end;
end;
end else okDate := true;
if not okDate then SoundBell(BeepTime,BeepFreq);
until okDate;
end;
Procedure AcceptL;
var
data : string[1];
begin
{
┌─────────────────────────────────────┐
│ Accept keyboard entry. Loop until │
│ value is T,t,Y,y,F,f,N,n. │
└─────────────────────────────────────┘
}
repeat
if t = '' then t := 'F';
AcceptC;
if not EditOn then exit;
if t[1] in ['T','t','Y','y','F','f','N','n'] then
begin end else SoundBell(BeepTime,BeepFreq);
until t[1] in ['T','t','Y','y','F','f','N','n'];
if t[1] in ['T','t','Y','y'] then t[1] := 'T' else t[1] := 'F';
end;
procedure AcceptM;
var
ans : string[10]; {Work string to hold edit value}
r_c : string[10]; {Work string for memo block number}
begin
GS_Wind_SetIvMode;
ans := 'N'; {Initialize ans to false}
if EditOn then write(' Edit ? ') else write(' View ? ');
repeat
ans := EditString(ans,v+9,y,1);
{Go edit string t for 1 character}
{at cursor position v,y}
if ans[1] in ['T','t','Y','y','F','f','N','n'] then
begin end else SoundBell(BeepTime,BeepFreq);
until ans[1] in ['T','t','Y','y','F','f','N','n'];
GS_Wind_SetNmMode; {Restore original text attribute}
gotoxy(v,y); {Now reset to 'memo' for field name}
write('---memo---');
if ans[1] in ['T','t','Y','y'] then
begin
r_c := t;
MemoGet(t);
If EditOn then Memo_Store.Edit else Memo_Store.View;
if (EditOn) and (GS_KeyI_Esc) then
begin
GS_KeyI_Esc := false; {Reset Escape flag so its not used}
{elsewhere}
GS_KeyI_Chr := ' ';
MemoGet(t);
end
else
begin
GS_KeyI_Chr := ' '; {Clear character last entered}
if EditOn then t := MemoPut;
if t <> r_c then RecChanged := true;
end;
end;
end;
Procedure AcceptN;
var
data : string;
i : integer;
r : real;
begin
{
┌─────────────────────────────────────┐
│ Accept keyboard entry. Loop until │
│ value is Numeric. │
└─────────────────────────────────────┘
}
repeat
if t = '' then Str(0.0:LastFldLth:LastFldDec,t);
AcceptC;
if not EditOn then exit;
val(t, r, i);
if i = 0 then
begin
Str(r:LastFldLth:LastFldDec,t);
if length(t) > LastFldLth then i := 999;
end;
if i <> 0 then
begin
SoundBell(BeepTime,BeepFreq);
t := '';
end;
until i = 0; {i will be 0 when data is a valid number}
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Rewrite the string on screen in the original color}
end;
begin
GotoXY(x,y); {Go to position on screen}
write(Titl); {Write the title of field}
v := WhereX; {Save the position after writing title}
t := TrimR(FieldGet(st)); {Get the field in the work string}
case LastFldTyp of
'C' : begin
AcceptC;
FieldAccept := t; {Return the string to calling routine}
end;
'D' : begin
AcceptD;
FieldAccept := t;
end;
'L' : begin
AcceptL;
FieldAccept := t;
end;
'M' : begin
AcceptM;
FieldAccept := t;
end;
'N' : begin
AcceptN;
FieldAccept := t;
end;
end;
end;
Procedure GS_dBFld_Objt.FieldDisplay(st,Titl : string; x,y : integer);
var
i,
v : integer; {Counter variables}
t : string[255]; {Work string to hold default (old) value}
data : string[10];
begin
GotoXY(x,y); {Go to position on screen}
write(Titl); {Write the title of field}
v := WhereX; {Save the position after writing title}
t := TrimR(FieldGet(st)); {Get the field in the work string}
case LastFldTyp of
'C',
'L' : begin
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Write the string on screen }
end;
'D' : begin
t := GS_Date_View(GS_Date_Juln(t));;
write(t);
end;
'N' : begin
if t = '' then t := '0';
gotoxy(v,y); {Go to start of field screen position}
write(t:LastFldLth);
end;
'M' : begin
gotoxy(v,y); {Go to start of field screen position}
write('---memo---'); {Write the '---memo--- on screen }
end;
end;
end;
Function GS_dBFld_Objt.FieldDisplayScreen : boolean;
var
f,
h : boolean;
begin
h := EditOn;
EditOn := false;
f := FieldUpdateScreen;
EditOn := h;
FieldDisplayScreen := f;
end;
function GS_dBFld_Objt.FieldGetN(n : integer) : String;
var
os,
fs : longint;
i,
k : integer;
FSt,
WSt : string[255];
NSt : string[10];
begin
fs := n; {Initialize field count}
if (fs <= NumFields) then
BEGIN
os := 1;
WITH Fields^[fs] DO
BEGIN
CnvAscToStr(FieldName,FSt,11);
FSt := TrimR(FSt); {Remove trailing spaces}
move(CurRecord^[FieldAddress], WSt[1], FieldLen);
WSt[0] := char(FieldLen); {Set string length to field length}
FieldGetN := WSt;
LastFldTyp := FieldType;
LastFldDec := FieldDec;
LastFldLth := FieldLen;
LastFldNum := fs;
LastFldNam := FSt;
end;
end else
begin
str(n,NSt);
ShowError(603,NSt);
FieldGetN := '';
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
function GS_dBFld_Objt.FieldGet(st : string) : String;
var
fs : integer;
begin
if HuntFieldName(st,fs) then FieldGet := FieldGetN(fs)
else
begin
ShowError(602,st);
FieldGet := '';
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
Procedure GS_dBFld_Objt.FieldPutN(n : integer; st1 : string);
var
os,
fs : longint;
i,
k : integer;
FSt,
WSt : string[255];
NSt : string[10];
begin
fs := n; {Initialize field count}
if (fs <= NumFields) then
BEGIN
WITH Fields^[fs] DO
BEGIN
move(FieldName,FSt[1],11);
FSt[0] := #11;
FSt[0] := char(pred(pos(#0,FSt)));
FSt := TrimR(FSt); {Remove trailing spaces}
FillChar(CurRecord^[FieldAddress], FieldLen, ' ');
k := length(st1); {Get length of input string}
if k > FieldLen then k := FieldLen;
Move(st1[1], CurRecord^[FieldAddress], k);
LastFldTyp := FieldType;
LastFldDec := FieldDec;
LastFldLth := FieldLen;
LastFldNum := fs;
LastFldNam := FSt;
end;
end else
begin
str(n,NSt);
ShowError(605,NSt);
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
Procedure GS_dBFld_Objt.FieldPut(st1, st2 : string);
var
fs : integer;
begin
if HuntFieldName(st1,fs) then FieldPutN(fs,st2)
else
begin
ShowError(604,st1);
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
Function GS_dBFld_Objt.FieldUpdateScreen : boolean;
var
b,
i,
v,
x,
y,
ll : integer;
st,
s : string[12];
t : string;
activlin,
activfld : integer;
Procedure UpdatePage;
var
validcmd : boolean;
begin
validcmd := false;
if activfld < b then activfld := b;
if activfld >= b+v then activfld := pred(b+v);
activlin := succ(activfld - b);
if (activlin < 1) or (activlin > v) then activlin := 1;
repeat
t := FieldAccept(FieldsN^[activfld],'',13,activlin);
if (EditOn) and (not GS_KeyI_Esc) then FieldPutN(activfld,t);
if (not GS_KeyI_Fuc) and (GS_KeyI_Chr >= #32) then
GS_KeyI_Chr := Kbd_Ret;
case GS_KeyI_Chr of
Kbd_F9 : begin
gotoxy(3,ll);
GS_Wind_SetIvMode;
if DelFlag then write('Deleted')
else write('':8);
GS_Wind_SetNmMode;
end;
Kbd_PgUp : begin
if activfld = b then
begin
b := b-v;
if b < 1 then b := 1;
validcmd := true;
end
else activfld := b;
end;
Kbd_PgDn : begin
if activfld = pred(b+v) then
begin
b := b+v;
if b > NumFields-v then b := succ(NumFields-v);
if b < 1 then b := 1;
validcmd := true;
end
else activfld := pred(b+v);
end;
Kbd_UpAr : begin
dec(activfld);
if activfld < b then
begin
dec(b);
if b < 1 then b := 1;
validcmd := true;
end;
end;
Kbd_RtAr,
Kbd_Tab,
Kbd_Ret,
Kbd_DnAr : begin
inc(activfld);
if activfld > pred(b+v) then
begin
if activfld > NumFields then
activfld := NumFields
else
begin
inc(b);
if b > NumFields then
b := succ(NumFields-v);
validcmd := true;
end;
end;
end;
Kbd_Esc,
Kbd_F10 : validcmd := true;
end;
if activfld < b then activfld := b;
if activfld >= b+v then activfld := pred(b+v);
activlin := succ(activfld - b);
if (activlin < 1) or (activlin > v) then activlin := 1;
until validcmd;
end;
begin
ClrScr;
DeleteOnF9 := true;
RecChanged := false;
b := 1;
activfld := b;
ll := succ(hi(WindMax)-hi(WindMin));
v := pred(ll);
GS_Wind_SetIvMode;
gotoxy(2,ll);
write('':pred(lo(WindMax)-lo(WindMin)));
if EditOn then
begin
if RecNumber < 0 then {If Append, do the following}
begin
gotoxy(12,ll);
write('Append ');
write('EOF/',NumRecs);
end
else
begin {If Update do the following}
gotoxy(12,ll);
write('Update ');
write(RecNumber,'/',NumRecs);
end;
end else
begin {If Display then do this}
gotoxy(12,ll);
write('Display ');
write(RecNumber,'/',NumRecs);
end;
if DelFlag then
begin
gotoxy(3,ll);
write('Deleted');
end;
GS_Wind_SetNmMode;
if NumFields < v then v := NumFields;
x := 1;
y := 1;
Ch := ' ';
repeat
for i := b to pred(b+v) do
begin
s := FieldsN^[i];
FillChar(st[1],12,' ');
move(s[1],st[11-length(s)],length(s));
st[11] := ':';
st[0] := #12;
FieldDisplay(s,st,x,y);
case LastFldTyp of
'M' : begin
gotoxy(x+12,y);
write('---memo---');
if RecNumber < 0 then FieldPutN(LastFldNum,' ');
{If Append, make sure memo field is not}
{pointing to a memo block }
end;
end;
ClrEol;
inc(y);
end;
UpdatePage;
y := 1;
until (GS_KeyI_Chr in [Kbd_Esc,Kbd_F10]) or
((GS_KeyI_Chr = Kbd_PgUp) and (activfld = 1)) or
((GS_KeyI_Chr = Kbd_PgDn) and (activfld = NumFields));
DeleteOnF9 := false;
if GS_KeyI_Chr in [Kbd_F10, Kbd_PgUp, Kbd_PgDn] then
FieldUpdateScreen := true
else FieldUpdateScreen := false;
end;
Function GS_dBFld_Objt.FieldAppendScreen(empty : boolean) : boolean;
begin
if empty then Blank;
CurRecord^[0] := 32; {Ensure delete flag is off}
DelFlag := false;
RecNumber := -1;
FieldAppendScreen := FieldUpdateScreen;
end;
Function GS_dBFld_Objt.Formula(st : string; var ftyp : char) : string;
var
FldVal,
FldWrk : string;
FldPos : integer;
function HuntField(fldst : string) : String;
var
fs : integer;
ss : string;
FSt : string;
mtch : boolean;
begin
FSt := AllCaps(fldst); {Capitalize the workstring}
FSt := TrimR(FSt); {Remove trailing spaces}
fs := 1; {Initialize field count}
mtch := false; {Set match found to false}
while (not mtch) and (fs <= NumFields) DO
if FieldsN^[fs] = FSt then mtch := true else inc(fs);
if mtch then
begin
WITH Fields^[fs] DO
BEGIN
move(CurRecord^[FieldAddress], FSt[1], FieldLen);
FSt[0] := char(FieldLen); {Set string length to field length}
ftyp := FieldType;
HuntField := FSt;
end;
end
else
begin
ss := TrimL(fldst);
if ss = '' then
begin
HuntField := '';
exit;
end;
if ss[1] = '"' then
begin
ss := TrimR(ss);
system.delete(ss,1,1);
if ss[length(ss)] = '"' then ss[0] := chr(pred(length(ss)));
HuntField := ss;
exit;
end;
ShowError(601,st+' ('+fldst+')');
HuntField := '';
end;
end;
begin
FldVal := ''; {Initialize the return string value}
FldWrk := st; {Move the input string to a work field}
while FldWrk <> '' do {Repeat while there is still something}
{in the work field.}
begin
FldPos := pos('+', FldWrk); {Search for a '+' delimiter}
if FldPos = 0 then FldPos := length(FldWrk)+1;
{If no '+' then simulate for this pass}
{by setting position to one beyond the}
{end of the target field string.}
FldVal := FldVal + HuntField(SubStr(FldWrk,1,FldPos-1));
{Go find the field using the substring}
{from the string's beginning to one }
{position before the '+' character.}
system.delete(FldWrk,1,FldPos); {Delete the string up through the '+'};
FldWrk := TrimL(FldWrk); {Remove leading spaces}
end;
Formula := FldVal; {Return value to calling routine}
end;
Procedure GS_dBFld_Objt.IndexTo(filname, formla : string);
var
i,
j,
fl : integer; {Local working variable}
ft : char;
ftyp : char;
fval : longint;
fkey : string;
{
┌──────────────────────────────────────────────────┐
│ This routine will accumulate the field length │
│ of all fields passes in the calling argument. │
│ This is needed to pass the formula length to │
│ create the index header. │
└──────────────────────────────────────────────────┘
}
procedure AccumField;
var
FldWrk : string;
FldLoc,
FldPos : integer;
begin
ft := '*'; {Set field type to new '*'}
fl := 0; {initialize field length}
FldWrk := TrimR(formla); {Remove trailing spaces from argument}
while FldWrk <> '' do {Repeat while there is still something}
{in the work field.}
begin
FldPos := pos('+', FldWrk); {Search for a '+' delimiter}
if FldPos = 0 then FldPos := length(FldWrk)+1;
{If no '+' then simulate for this pass}
{by setting position to one beyond the}
{end of the target field string.}
{Go find the field using the substring}
{from the string's beginning to one }
{position before the '+' character.}
if not HuntFieldName(SubStr(FldWrk,1,FldPos-1),FldLoc) then
begin
fl := 0;
exit;
end;
if ft = '*' then ft := LastFldTyp
else ft := 'C'; {Set type to C if more than one field}
{Else save this field's type }
fl := fl + Fields^[FldLoc].FieldLen;
{If a valid field, then add the field}
{length to the total field length value.}
system.delete(FldWrk,1,FldPos);
{Delete the string up through the '+'};
FldWrk := TrimL(FldWrk); {Remove leading spaces}
end;
end;
{
┌──────────────────────────────────────────────────┐
│ Main routine. This takes and analyzes the │
│ argument to build an index file. It does the │
│ following: │
│ 1. Reset current index files. │
│ 2. Get the total new formula field length. │
│ 3. Create an index file. │
│ 4. Build the index by reading all dbase │
│ records and updating the index file. │
└──────────────────────────────────────────────────┘
}
begin
StatusUpdate(StatusStart,StatusIndexTo,NumRecs);
i := 1;
while dbfNdxTbl[i] <> nil do
begin
dbfNdxTbl[i]^.Ndx_Close;
Dispose(dbfNdxTbl[i]);
dbfNdxTbl[i] := nil;
inc(i);
end;
dbfNdxActv := false; {Set index active flag to false}
if formla <> '' then
begin
AccumField; {Get field length of the formula}
if fl = 0 then
begin
ShowError(601,formla); {Display Error if formula is bad}
exit; {Exit if formula is no good}
end;
New(dbfNdxTbl[1]); {Create a new index object}
dbfNdxTbl[1]^.Ndx_Make(filname, formla, fl, ft);
{Go create an index}
Open;
GetRec(Top_Record); {Read all dBase file records}
while not File_EOF do
begin
fkey := Formula(formla,ftyp);
if (IsDB3NDX) and (ftyp = 'D') then
begin
fval := GS_Date_Juln(fkey);
str(fval,fkey);
end;
dbfNdxTbl[1]^.KeyUpdate(fkey,RecNumber,-1);
{Insert record in the index}
StatusUpdate(StatusIndexTo,RecNumber,0);
GetRec(Next_Record);
end;
{ dbfNdxTbl[1]^.KeyList('PRN');}
dbfNdxActv := true; {Set index active flag true if index }
GetRec(Top_Record); {Reset to top record}
end;
StatusUpdate(StatusStop,0,0);
end;
constructor GS_dBFld_Objt.Init(FName : string);
begin
EditOn := true;
GS_dBase_DB.Init(FName);
Memo_Store.Init; {Initialize the edit object}
Memo_Store.Edit_Lgth := 50; {Set default memo line size to 50}
Wait_Cr := false; {Set EditString not to wait for CR}
DeleteOnF9 := false; {Turn off F9 for delete/undelete}
end;
function GS_dBFld_Objt.MemoGetLine(linenum : integer) : string;
begin
if linenum > Memo_Store.Total_Lines then
begin
MemoGetLine := '';
exit;
end;
if not Memo_Store.Find_Line(linenum) then
begin
MemoGetLine := '';
exit;
end;
MemoGetLine := Memo_Store.Work_line^.Valu_Line;
end;
Procedure GS_dBFld_Objt.MemoGet(rpt : string);
const
EOFMark : byte = $1A; {End of disk file code}
var
cnt, {Counter for memo storage location}
lCnt, {Counter for line length in characters}
mCnt : longint; {Counter for input buffer char position}
Result : word; {BlockRead number of bytes read}
done : boolean; {Flag set when end of memo field found}
i,j : integer; {Working variable}
Mem_Block : array [0..GS_dBase_MaxMemoRec] of byte;
{Input buffer}
BEGIN { Get Memo Field }
Val(rpt, Memo_Loc, i); {Save starting block number}
Memo_Bloks := 0; {Initialize blocks read}
Memo_Store.Clear_Editor; {Begin memo line count at zero}
{
┌─────────────────────────────────────┐
│ If no .DBT memo field for this │
│ record, then exit. │
└─────────────────────────────────────┘
}
if (Memo_Loc = 0) then exit;
Memo_Store.Work_Line := Memo_Store.Get_Line_Mem(Memo_Store.Edit_Lgth);
{Get the first edit line record}
Memo_Store.Active_Line := 1; {Set active line to first line}
done := false; {Reset done flag to false}
cnt := 0; {index into Memo_Store buffer}
lCnt := 0; {line length counter}
BEGIN
while (not done) do {loop until done (EOF mark)}
begin
GS_FileRead(mFile, Memo_Loc+Memo_Bloks, Mem_Block, 1, Result);
inc(Memo_Bloks);
mCnt := 0; {Counter into disk read buffer}
{
┌─────────────────────────────────────┐
│ Start reading and processing the │
│ sequential memo blocks until EOF │
│ mark is found. │
└─────────────────────────────────────┘
}
while (mCnt < GS_dBase_MaxMemoRec) and
(done = false) do
{
┌────────────────────────────────────────────┐
│ Repeat the following until you find an │
│ End-of-Memo condition. Read the next │
│ block each time mCnt reaches 512 bytes │
│ (GS_dBase_MaxMemoRec. Group the memo │
│ as a series of lines no greater than │
│ Memo_Width long. │
└────────────────────────────────────────────┘
}
begin
case Mem_Block[mCnt] of {Check for control characters}
$1A : begin
done := true; {End of Memo field}
if Memo_Store.Work_line^.Valu_Line = '' then
Memo_Store.Rel_Line_Mem(Memo_Store.Active_Line);
end;
$8D : begin {Soft Return (Wordstar and dBase editor)}
if (Memo_Store.Work_Line^.Valu_Line[lCnt] <> ' ') and
(Memo_Store.Work_Line^.Valu_Line[lCnt] <> '-') and
(lCnt > 0) then
begin
inc(lCnt); {Add to line length count}
Memo_Store.Work_Line^.Valu_Line[lcnt] := ' ';
{Insert a space in storage}
Memo_Store.Work_Line^.Valu_Line[0] := chr(lcnt);
end;
end;
$0A : begin {Linefeed}
end; {Ignore these characters}
$0D : begin {Hard Return}
With Memo_Store do
begin
Work_Line^.Return_Cod := $0D;
Work_Line := Get_Line_Mem(Edit_Lgth);
inc(Memo_Store.Active_Line);
lCnt := 0;
end;
end;
else {Here for other characters}
begin
inc(lCnt); {Add to line length count}
Memo_Store.Work_Line^.Valu_Line[lcnt] :=
chr(Mem_Block[mCnt]);
{Insert the character in storage}
Memo_Store.Work_Line^.Valu_Line[0] := chr(lcnt);
end;
end;
inc(mCnt); {Step to next input buffer location}
if lCnt > Memo_Store.Edit_Lgth then
{If lcnt longer than Memo_Width, you}
{must word wrap to Memo_Width length}
{or less}
begin
while (Memo_Store.Work_Line^.Valu_Line[lCnt] <> ' ') and
(Memo_Store.Work_Line^.Valu_Line[lCnt] <> '-') and
(lCnt > 0) do dec(lCnt);
{Repeat search for space or hyphen until}
{found or current line exhausted}
if (lCnt = 0) then
lcnt := length(Memo_Store.Work_Line^.Valu_Line) - 1;
{If no break point, truncate line}
with Memo_Store do
begin
Temp_Line := Work_Line^.Valu_Line;
system.delete(Temp_Line,1,lCnt);
if lCnt > Memo_Store.Edit_Lgth then
lCnt := Memo_Store.Edit_Lgth;
Work_Line^.Valu_Line[0] := chr(lcnt);
{Get string up to cursor to split line}
Work_Line := Get_Line_Mem(Edit_Lgth);
inc(Memo_Store.Active_Line);
Work_Line^.Return_Cod := $8D;
{Insert soft return character}
Work_Line^.Valu_Line := Temp_Line;
lCnt := length(Work_Line^.Valu_Line);
end;
end;
end;
END;
end;
END; { Get Memo Field }
Procedure GS_dBFld_Objt.MemoEdit;
begin
Memo_Store.Edit;
end;
Function GS_dBFld_Objt.MemoLines : integer;
begin
MemoLines := Memo_Store.Total_Lines;
end;
Procedure GS_dBFld_Objt.MemoWidth(l : integer);
begin
Memo_Store.Edit_Lgth := l;
end;
Function GS_dBFld_Objt.MemoPut : string;
const
EOFMark : byte = $1A; {End of disk file code}
var
bCnt, {Will hold bytes in memo field}
lCnt, {Counter for line length in characters}
mCnt,
tcnt : longint; {Counter for input buffer char position}
Result : word; {BlockWrite number of bytes written}
i : longint; {Working variable}
Mem_Block : array [0..GS_dBase_MaxMemoRec*2] of byte;
{Output buffer}
valu : string[10]; {work string to convert block number}
BEGIN { Put Memo Field }
bCnt := Memo_Store.Byte_Count; {Get count of bytes in memo field}
bCnt := bcnt div GS_dBase_MaxMemoRec;
{Get number of blocks required}
inc(bCnt); {Adjust from zero}
if bCnt > Memo_Bloks then
begin
GS_FileRead(mFile, 0, Mem_Block, 1, Result);
{read a block from the .DBT}
Move(Mem_Block[0],Memo_Loc,4);
{Get next block number to append}
end;
Memo_Bloks := bCnt; {Set blocks written count}
lCnt := 0; {line length counter}
mCnt := 0; {Counter into disk write buffer}
tCnt := Memo_Loc;
{
┌─────────────────────────────────────┐
│ Start reading and processing the │
│ sequential memo blocks until EOF │
│ mark is found. │
└─────────────────────────────────────┘
}
with Memo_Store do
begin
Work_Line := First_Line;
while (Work_Line <> nil) do
begin
move(Work_Line^.Valu_Line[1],Mem_Block[mCnt],
length(Work_Line^.Valu_Line));
mCnt := mCnt + length(Work_Line^.Valu_Line);
if Work_Line^.Next_Line <> nil then
begin
Mem_Block[mCnt] := Work_Line^.Return_Cod;
Mem_Block[mCnt+1] := $0A;
inc(mCnt,2);
end;
Work_Line := Work_Line^.Next_Line;
if (mCnt > GS_dBase_MaxMemoRec) then
begin
GS_FileWrite(mFile,tcnt,Mem_Block,1, Result);
{read a block from the .DBT}
inc(tcnt);
mCnt := mCnt mod GS_dBase_MaxMemoRec;
{Get excess buffer length used}
Move(Mem_Block[GS_dBase_MaxMemoRec],Mem_Block[0],mCnt);
{Move excess to beginning of buffer}
end;
end;
Mem_Block[mCnt] := EOFMark;
FillChar(Mem_Block[succ(mcnt)],GS_dBase_MaxMemoRec - mcnt,#0);
GS_FileWrite(mFile,tcnt,Mem_Block,1, Result);
{Write the last block to the .DBT}
i := GS_FileSize(mFile);
FillChar(Mem_Block,GS_dBase_MaxMemoRec,#0);
Move(i,Mem_Block[0],4);
GS_FileWrite(mFile,0,Mem_Block,1, Result);
{Write the block to the .DBT. It will}
{point to the next available block};
end;
Str(Memo_Loc:10,valu);
MemoPut := valu;
end;
Procedure GS_dBFld_Objt.StatusUpdate(statword1,statword2,statword3 : longint);
begin
end;
end.
